home *** CD-ROM | disk | FTP | other *** search
/ Planet Source Code Jumbo …e CD Visual Basic 1 to 7 / 5_2007-2008.ISO / data / Zips / MSNP12_VB_2047842142007.psc / MSNP12 VB / Modules / modMD5.bas < prev    next >
BASIC Source File  |  2007-02-13  |  3KB  |  78 lines
  1. Attribute VB_Name = "modMD5"
  2. '-----------------------------------------------------------------
  3. ' baseMD5: Provide MD5 and SHA1 through cryptographic APIs
  4. '-----------------------------------------------------------------
  5.  
  6. Option Explicit
  7.  
  8. 'Functions
  9. Private Declare Function CryptAcquireContext Lib "advapi32.dll" Alias "CryptAcquireContextA" (ByRef phProv As Long, ByVal pszContainer As String, ByVal pszProvider As String, ByVal dwProvType As Long, ByVal dwFlags As Long) As Long
  10. Private Declare Function CryptReleaseContext Lib "advapi32.dll" (ByVal hProv As Long, ByVal dwFlags As Long) As Long
  11. Private Declare Function CryptCreateHash Lib "advapi32.dll" (ByVal hProv As Long, ByVal Algid As Long, ByVal hKey As Long, ByVal dwFlags As Long, ByRef phHash As Long) As Long
  12. Private Declare Function CryptDestroyHash Lib "advapi32.dll" (ByVal hHash As Long) As Long
  13. Private Declare Function CryptHashData Lib "advapi32.dll" (ByVal hHash As Long, pbData As Any, ByVal dwDataLen As Long, ByVal dwFlags As Long) As Long
  14. Private Declare Function CryptGetHashParam Lib "advapi32.dll" (ByVal hHash As Long, ByVal dwParam As Long, pbData As Any, pdwDataLen As Long, ByVal dwFlags As Long) As Long
  15.  
  16. 'SHA1/MD5 consts
  17. Private Const PROV_RSA_FULL = 1
  18. Private Const ALG_CLASS_HASH = 32768
  19. Private Const ALG_TYPE_ANY = 0
  20. Private Const HP_HASHVAL = 2
  21. Private Const HP_HASHSIZE = 4
  22.  
  23. 'SHA1 consts
  24. Private Const ALG_SID_SHA1 = 4
  25. Private Const SHA1 = ALG_CLASS_HASH Or ALG_TYPE_ANY Or ALG_SID_SHA1
  26.  
  27. 'MD5 consts
  28. Private Const ALG_SID_MD5 = 3
  29. Private Const CALG_MD5 = ((ALG_CLASS_HASH Or ALG_TYPE_ANY) Or ALG_SID_MD5)
  30.  
  31. Public Function MD5_Hex(ByVal Str As String) As String
  32.     'Pass :)
  33.     MD5_Hex = LCase$(CreateHash(Str, CALG_MD5))
  34. End Function
  35.  
  36. Public Function SHA1_Hex(ByVal Str As String) As String
  37.     'Pass :)
  38.     SHA1_Hex = CreateHash(Str, SHA1)
  39. End Function
  40.  
  41. Public Function CreateHash(ByVal Str As String, ByVal ConstVal As Long) As String
  42.     'Create hash :)
  43.     Dim hCtx As Long, hHash As Long, lRes As Long, lLen As Long, lIdx As Long, abData() As Byte
  44.  
  45.     'Get default provider context handle
  46.     lRes = CryptAcquireContext(hCtx, vbNullString, vbNullString, PROV_RSA_FULL, 0)
  47.  
  48.     If lRes <> 0 Then
  49.         'Create the hash
  50.         lRes = CryptCreateHash(hCtx, ConstVal, 0, 0, hHash)
  51.         If lRes <> 0 Then
  52.             lRes = CryptHashData(hHash, ByVal Str, Len(Str), 0)
  53.             If lRes <> 0 Then
  54.                 lRes = CryptGetHashParam(hHash, HP_HASHSIZE, lLen, 4, 0)
  55.                 If lRes <> 0 Then
  56.                     ReDim abData(0 To lLen - 1)
  57.  
  58.                     'Get the hash value
  59.                     lRes = CryptGetHashParam(hHash, HP_HASHVAL, abData(0), lLen, 0)
  60.                     If lRes <> 0 Then
  61.                         'Convert value to hex string
  62.                         For lIdx = 0 To UBound(abData)
  63.                             CreateHash = CreateHash & Right$("0" & Hex$(abData(lIdx)), 2)
  64.                         Next
  65.                     End If
  66.                 End If
  67.             End If
  68.  
  69.             'Release the hash handle
  70.             CryptDestroyHash hHash
  71.         End If
  72.     End If
  73.  
  74.     'Release the provider context
  75.     CryptReleaseContext hCtx, 0
  76. End Function
  77.  
  78.